Power Programmierung/Power-Programmierung (Tewi)(1994).iso/magazine/progjour/1988/05/objdraw.pas

Pascal/Delphi Source File | 1988-08-18 | 10KB | 328 lines

Copyright Tom Swan, 1988.  All Rights Reserved.

PROGRAM ObjDraw;

{ Raw beginnings of an object-oriented graphics program,
demonstrating a practical use for variable-length data structures.
Written for Programmer's Journal by Tom Swan, Swan Software, P.O. Box
206, Lititz PA 17543. }


USES  Crt, Graph;


CONST

   FileName = 'OBJECTS.TXT';     { Graphics objects file name }
   GrPath = 'C:\TPAS4';          { Pathname to BGI drivers }
   MaxWord = 65535;              { Maximum Word value }


TYPE

   ObjType = ( {0} ObjPoint, {1} ObjLine, {2} ObjRect, {3} ObjCircle );

   PointRec =                    { Single-pixel points }
      RECORD
         x, y : Integer;               { Location of point }
         pointColor : Word             { Color of point }
      END;

   LineRec =                     { Straight lines }
      RECORD
         x1, y1, x2, y2 : Integer;     { Line endpoints }
         lineColor : Word              { Line color }
      END;

   RectRec =                     { Squares and rectangles }
      RECORD
         x1, y1, x2, y2 : Integer;     { Rectangle corners }
         lineColor : Word;             { Outline color }
         fillColor : Word              { Interior color (0=none) }
      END;

   CircleRec =                   { Circles }
      RECORD
         x, y : Integer;               { Center coordinate }
         radius : Word;                { Length of radius in pixels }
         lineColor : Word;             { Outline color }
         fillColor : Word              { Interior color (0=none) }
      END;

   ObjPtr = ^ObjRec;             { Pointer to various graphics objects }
   ObjRec =
      RECORD CASE objKind : ObjType OF
         ObjPoint    : ( onePoint  : PointRec  );
         ObjLine     : ( oneLine   : LineRec   );
         ObjRect     : ( oneRect   : RectRec   );
         ObjCircle   : ( oneCircle : CircleRec )
      END;

   ObjListPtr = ^ObjList;        { Pointer to list of graphics objects }
   ObjList =
      RECORD
         numObjects : Word;                     { Number of objects }
         objects : ARRAY[ 0 .. 0 ] OF ObjPtr    { Variable-length array }
      END;


VAR

   obj : ObjListPtr;    { Pointer to list of objects }



PROCEDURE NewObjList( n : Word; VAR obj : ObjListPtr );

{ Return pointer obj to an ObjList record large enough to hold n
ObjPtr pointers in the obj^.objects array field.  If obj=Nil on
return, then 1) n=0; or 2) bytes requested > MaxWord; or 3) enough
memory for n items is not available. }

VAR   size : LongInt;   { Number of bytes to allocate }

BEGIN
   size := SizeOf( Word ) + ( LongInt(n) * SizeOf( ObjRec ) );
   IF ( size = 0 ) OR ( size > MaxWord ) THEN obj := Nil ELSE
   BEGIN
      GetMem( obj, size );    { Out-of-memory error sets obj to Nil }
      IF obj <> Nil
         THEN obj^.numObjects := n
   END { if }
END; { NewObjList }


PROCEDURE NewObj( n : Word; VAR obj : ObjPtr );

{ Return pointer obj to an ObjRec record large enough to hold n
bytes plus the record tag field.  Out-of-memory error returns
obj = Nil. }

BEGIN
   GetMem( obj, n + SizeOf( ObjType ) )
END; { NewObj }


FUNCTION NextObject( VAR f : Text ) : ObjPtr;

{ Read next object data from disk, creating an ObjRec record large
enough to hold the data, and returning the address of this record
as the function result.  Out-of-memory error returns Nil. }

VAR   objCode : Word;      { Object code number (from data file) }
      p : ObjPtr;          { Temporary single object pointer }

   FUNCTION LoadPoint : ObjPtr;
   { Load one point object }
   BEGIN
      NewObj( SizeOf( PointRec ), p );    { Allocate memory }
      IF p <> Nil THEN WITH p^.onePoint DO
         Read( f, x, y, pointColor );     { Read data }
      LoadPoint := p                      { Return function result }
   END; { LoadPoint }

   FUNCTION LoadLine : ObjPtr;
   { Load one line object }
   BEGIN
      NewObj( SizeOf( LineRec ), p );
      IF p <> Nil THEN WITH p^.oneLine DO
         Read( f, x1, y1, x2, y2, lineColor );
      LoadLine := p
   END; { LoadLine }

   FUNCTION LoadRect : ObjPtr;
   { Load one rectangle object }
   BEGIN
      NewObj( SizeOf( RectRec ), p );
      IF p <> Nil THEN WITH p^.oneRect DO
         Read( f, x1, y1, x2, y2, lineColor, fillColor );
      LoadRect := p
   END; { LoadRect }

   FUNCTION LoadCircle : ObjPtr;
   { Load one circle object }
   BEGIN
      NewObj( SizeOf( CircleRec ), p );
      IF p <> Nil THEN WITH p^.oneCircle DO
         Read( f, x, y, radius, lineColor, fillColor );
      LoadCircle := p
   END; { LoadCircle }

BEGIN
   Read( f, objCode );                 { Read object code number }
   CASE ObjType( objCode ) OF
      ObjPoint    : p := LoadPoint;    { Read point data }
      ObjLine     : p := LoadLine;     { Read line data }
      ObjRect     : p := LoadRect;     { Read rectangle data }
      ObjCircle   : p := LoadCircle    { Read circle data }
   END; { case }
   IF p <> Nil
      THEN p^.objKind := ObjType( objCode );   { Save code as tag field }
   NextObject := p                     { Return function result }
END; { NextObject }


PROCEDURE LoadFile( VAR obj : ObjListPtr );

{ Read graphics objects from a disk file.  Halts on errors. }

VAR   f : Text;               { Text file variable }
      n : Word;               { Number of objects }
      i : Word;               { For-loop control variable }

BEGIN
   Assign( f, FileName );     { Assign file name to file variable }
   Reset( f );                { Open file for input }
   Read( f, n );              { Read number of objects }
   NewObjList( n, obj );      { Create array to hold list of n objects }
   IF obj = Nil THEN          { Check for bad n or short memory }
   BEGIN
      Writeln;
      Writeln( 'Cannot allocate space for ', n, ' objects' );
      Writeln( 'Memory available = ', MemAvail );
      Halt(1)
   END; { if }
   FOR i := 1 TO n DO         { Read n objects from disk }
      obj^.objects[i-1]       { Read next object and }
         := NextObject( f );  {  assign to variable-length array }
   Close( f )
END; { LoadFile }


PROCEDURE ShowOneObj( obj : ObjListPtr; n : Word );

{ Display object number n in object list addressed by obj pointer.
Assumes obj is not Nil.  Ignores any Nil pointers in obj^.objects
array. }

VAR   p : ObjPtr;    { Holds copy of obj^.objects[n] }

   PROCEDURE ShowPoint( VAR onePoint : PointRec );
   { Display point object }
   BEGIN
      WITH onePoint DO
         PutPixel( x, y, pointColor )
   END; { ShowPoint }

   PROCEDURE ShowLine( VAR oneLine : LineRec );
   { Display Line object }
   BEGIN
      WITH oneLine DO
      BEGIN
         SetColor( lineColor );
         Line( x1, y1, x2, y2 )
      END { with }
   END; { ShowLine }

   PROCEDURE ShowRect( VAR oneRect : RectRec );
   { Display Rect object }
   BEGIN
      WITH oneRect DO
      BEGIN
         IF fillColor > 0 THEN
         BEGIN
            SetFillStyle( SolidFill, fillColor );
            Bar( x1, y1, x2, y2 )
         END; { if }
         SetColor( lineColor );
         Rectangle( x1, y1, x2, y2 )
      END { with }
   END; { ShowRect }

   PROCEDURE ShowCircle( VAR oneCircle : CircleRec );
   { Display Circle object }
   BEGIN
      WITH oneCircle DO
      BEGIN
         SetColor( lineColor );
         Circle( x, y, radius );
         IF fillColor > 0 THEN
         BEGIN
            SetFillStyle( SolidFill, fillColor );
            FloodFill( x, y, lineColor )
         END { if }
      END { with }
   END; { ShowCircle }

BEGIN
   WITH obj^ DO
   IF ( 0 <= n ) AND ( n < numObjects ) THEN
   BEGIN
      p := objects[n];
      IF p <> Nil THEN WITH p^ DO
      CASE objKind OF
         ObjPoint    : ShowPoint( onePoint );
         ObjLine     : ShowLine( oneLine );
         ObjRect     : ShowRect( oneRect );
         ObjCircle   : ShowCircle( oneCircle )
      END { case }
   END { if }
END; { ShowOneObj }


PROCEDURE ShowAllObjects( obj : ObjListPtr );

{ Display all objects addressed by object list pointer obj.  Assumes
that obj is not Nil. }

VAR   i : Word;      { For-loop control variable }

BEGIN
   FOR i := 1 TO obj^.numObjects DO
      ShowOneObj( obj, i - 1 );
END; { ShowAllObjects }


PROCEDURE DoGraphics( obj : ObjListPtr );

{ Initialize graphics screen and display objects addressed by obj. }

VAR   grDriver, grMode, grError : Integer;   { BGI graphics variables }
      ch : Char;     { Holds keypresses }

BEGIN
   grDriver := Detect;
   InitGraph( grDriver, grMode, grPath );
   grError := GraphResult;
   IF grError <> GrOk
    THEN
      Writeln( 'Graphics error : ', GraphErrorMsg( grError ) )
    ELSE
      BEGIN
         ShowAllObjects( obj );
         REPEAT
            ch := ReadKey;
            ShowOneObj( obj, ( Ord(ch) - Ord('0') ) - 1 )
         UNTIL ch = Chr(27);
         CloseGraph
      END { else }
END; { DoGraphics }


{ The following custom heap-error trap function lets GetMem and New
return Nil pointers if memory allocation requests fail due to
insufficient memory. }

{$F+}    { Switch on far-procedure generation }
FUNCTION HeapErrorTrap( size : Word ) : Integer;
BEGIN
   HeapErrorTrap := 1      { New & GetMem: return Nil if out-of-memory }
END; { HeapErrorTrap }
{$F-}    { Switch off far-procedure generation }


BEGIN
   HeapError := @HeapErrorTrap;  { Assign custom heap-error trap address }
   Writeln;
   Writeln( 'Welcome to ObjDraw' );
   Writeln;
   Writeln( 'Reads data from file ', FileName );
   Writeln( 'Press digit keys to bring objects to the front' );
   Writeln( 'Press Esc to quit' );
   Writeln;
   Write( 'Press Enter to begin...' );
   Readln;
   LoadFile( obj );        { Load objects from disk }
   DoGraphics( obj )       { Display objects }
END.